home *** CD-ROM | disk | FTP | other *** search
/ HPAVC / HPAVC CD-ROM.iso / pc / 2924.ZIP / DMLXREF.ARC / DMLTEST.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-12-27  |  14.5 KB  |  455 lines
  1. {.PO 10}
  2.  
  3. {$N+}
  4. {$M 8192,0,0}
  5.  
  6. PROGRAM TestDMLUnit;
  7.  
  8. USES
  9.   CRT,                    { Turbo UNITs }
  10.   GEN, KBD, NUM, STRG;  { DML individual UNITs }
  11. { DML;  }               { DML 'LIB' of individual UNITs  }
  12.  
  13. VAR
  14.   ProgName : STRING;
  15.   Ctr      : INTEGER;
  16.   Start    : REAL;
  17.   Stop     : REAL;
  18.   Password : STRING;
  19.   TestFile : FILE OF CHAR;
  20.   TestBuf  : CHAR;
  21.   StrNum   : StrNumType; { StrNonNumeric,StrZero,StrNonZero }
  22.   CharArr  : ARRAY[1..255] OF CHAR;
  23.   JulSec   : REAL;
  24.   DateTime : T_DateTime;
  25.  
  26. PROCEDURE Continue;
  27. BEGIN
  28.   WRITELN(^J^M,'Press any key to continue, or * to exit ...');
  29.   IF READKEY = '*' THEN HALT;
  30.   CLRSCR;
  31. END;
  32.  
  33. {$F+}PROCEDURE Silly;{$F-}
  34. BEGIN
  35.   WRITELN('In a simple procedure invoked by passing its address as a parameter');
  36. END;
  37.  
  38. {$F+}PROCEDURE VerySilly(ProcAddrP : POINTER; I1 : INTEGER; VAR S1 : STRING; VAR I2 : INTEGER);{$F-}
  39. BEGIN
  40.   WRITELN('In a complex procedure invoked by passing its address as a parameter');
  41.   WRITELN('Input Params ',I1,' ',S1,' ',I2);
  42.   I1 := I1 + 5;  { won't change globally }
  43.   S1 := S1 + '!@';
  44.   I2 := I1;
  45. END;
  46.  
  47. PROCEDURE GenStart;
  48. BEGIN
  49.   CLRSCR;
  50.   WRITELN(CJS('GENERAL PURPOSE ROUTINES',80));
  51. END;
  52.  
  53. PROCEDURE Gen1;
  54. BEGIN
  55.   WRITELN(' 1) System Programming Extensions',^J^M);
  56.   WRITELN('>> CALLPROCEDURE <<');
  57.   CallProcedure(@Silly);
  58.   Ctr := 1000;
  59.   Password := 'PASSWORD';
  60.   WRITELN('>> CALLPROCEDUREX <<');
  61.   CallProcedureX(@VerySilly,12,Password,Ctr);
  62.   WRITELN('Output Params ',Password,' ',Ctr);
  63.   WRITELN('>> LONGADDR <<');
  64.   WRITELN('The full 32 bit hex address of $1234:$5678 is ',L2S(LongAddr($1234,$5678),'HHHHH'));
  65.   WRITELN('>> SAME <<');
  66.   IF Same(PassWord,PassWord,SIZEOF(PassWord))
  67.     THEN WRITELN('  This better work!')
  68.     ELSE WRITELN('  BUGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGGG!');
  69.   Continue;
  70. END;
  71.  
  72. PROCEDURE Gen2;
  73. BEGIN
  74.   ProgName := WhoAmI;
  75.   ProgName := COPY(ProgName,1,LENGTH(Progname)-3) + 'PAS';
  76.   WRITELN(' 2) File I/O and Protection',^J^M);
  77.   WRITELN('Check read only attributes');
  78.   WRITELN('>> READONLYGETATTR <<');
  79.   IF NOT ReadOnlyGetAttr(ProgName) THEN BEGIN
  80.     WRITELN('Setting this program to read only access');
  81.     WRITELN('>> READONLYSETATTR <<');
  82.     IF ReadOnlySetAttr(ProgName,On) <> 0 THEN Abend(240,NIL);
  83.     END;
  84.   IF EXIST(ProgName)
  85.     THEN Abend(241,NIL)
  86.     ELSE WRITELN('This program is now set read only');
  87.     WRITELN('>> READONLYEXIST <<');
  88.   IF ReadOnlyExist(ProgName)
  89.     THEN WRITELN('This read only program exists and has a time stamp of ',GetFileDateAndTimeLongInt(ProgName))
  90.     ELSE Abend(242,NIL);
  91.   WRITELN('About to read the read only program...');
  92.   DELAY(2000);
  93.   ASSIGN(TestFile,ProgName);
  94.   { RESET(TestFile);  executing this statement would get file access denied }
  95.   WRITELN('>> FILEOPEN <<');
  96.   IF FileOpen(TestFile,SIZEOF(TestBuf),Read_Only) <> 0 THEN Abend(243,NIL);
  97.   CLOSE(TestFile);
  98.   WRITELN('>> FILEASSIGNANDOPEN <<');
  99.   IF NOT FileAssignAndOpen(ProgName,TestFile,SIZEOF(TestBuf),Read_Only) THEN Abend(244,NIL);
  100.   WHILE NOT EOF(TestFile) DO BEGIN
  101.     READ(TestFile,TestBuf);
  102.     WRITE(TestBuf);
  103.     END;
  104.   CLOSE(TestFile);
  105.   WRITELN('Done reading');
  106.   IF ReadOnlySetAttr(ProgName,Off) = 0
  107.     THEN WRITELN('This program is set back to read/write access')
  108.     ELSE Abend(245,NIL);
  109.   Continue;
  110. END;
  111.  
  112. PROCEDURE Gen3;
  113. BEGIN
  114.   WRITELN(' 3) Text Encryption',^J^M);
  115.   WRITELN('>> ENCRYPT <<');
  116.   Password := EnCrypt('PASSWORD');
  117.   WRITELN('>> DECRYPT <<');
  118.   WRITELN('The encryped  password is ',Password,^J^M,
  119.           'the decrypted password is ',DeCrypt(Password));
  120.   Continue;
  121. END;
  122.  
  123. PROCEDURE Gen4;
  124. BEGIN
  125.   WRITELN(' 4) General Purpose Video',^J^M);
  126.   WRITELN('Listen to the annoying high pitch beep');
  127.   WRITELN('>> GENBEEP <<');
  128.   GenBeep(2000,1000);
  129.   WRITELN('>> COLORMONITORINSTALLED <<');
  130.   IF ColorMonitorInstalled
  131.     THEN WRITELN('Color Monitor Installed')
  132.     ELSE WRITELN('Monochrome Monitor Installed');
  133.   WRITELN('>> CURSOR <<');
  134.   Cursor(FALSE);
  135.   WRITELN('The cursor on the next line is invisible');
  136.   DELAY(2000);
  137.   Cursor(TRUE);
  138.   WRITELN('The cursor on the next line is back to normal');
  139.   DELAY(2000);
  140.   WRITELN('>> CURSORINSERTSIZE <<');
  141.   CursorInsertSize;
  142.   WRITELN('The cursor on the next line is fat');
  143.   DELAY(2000);
  144.   WRITELN('>> CURSOROVERWRITESIZE <<');
  145.   CursorOverwriteSize;
  146.   WRITELN('The cursor on the next line is back to normal');
  147.   DELAY(2000);
  148.   WRITELN('>> SCRBACKCURSORCOLOR <<');
  149.   WRITELN('The foreground color of the cursor is ',ScrForeCursorColor);
  150.   WRITELN('>> SCRFORECURSORCOLOR <<');
  151.   WRITELN('The background color of the cursor is ',ScrBackCursorColor);
  152.   Continue;
  153. END;
  154.  
  155. PROCEDURE Gen5;
  156. BEGIN
  157.   WRITELN(' 5) General Purpose Video',^J^M);
  158.   WRITELN('Watch the ',^],' character and hit any key to continue...');
  159.   WRITELN('>> PAUSE <<');
  160.   Pause;
  161.   WRITELN('>> SCRERRMSG <<');
  162.   ScrErrMsg('This is a test error Message');
  163.   WRITELN('>> SCRSTATMSG <<');
  164.   ScrStatMsg('This is a test status Message');
  165.   DELAY(2000);
  166.   WRITELN('>> SCRYN <<');
  167.   IF ScrYN('go to lunch')
  168.     THEN WRITELN('consume mass quantities')
  169.     ELSE WRITELN('starve');
  170.   WRITELN('>> SCRYOUARESURE <<');
  171.   IF ScrYouAreSure('cure world hunger')
  172.     THEN WRITELN('collect your Nobel Prize')
  173.     ELSE WRITELN('collect unemployment');
  174.   DELAY(2000);
  175.   WRITELN('>> WAIT <<');
  176.   WRITELN('Watch the WAIT message be displayed and then cleared');
  177.   Wait(TRUE);
  178.   DELAY(1000);
  179.   Wait(FALSE);
  180.   Continue;
  181. END;
  182.  
  183. PROCEDURE Gen6;
  184. BEGIN
  185.   WRITELN(' 6) Disk and Memory Sizes',^J^M);
  186.   WRITELN('>> BYTESONDISKFREE <<');
  187.   WRITELN('There are ',L2S(BytesOnDiskFree(' '),'###,###,###'), ' bytes of disk available on default drive');
  188.   WRITELN('>> FREEDOSMEM <<');
  189.   WRITELN('There are ',L2S(FreeDOSMem,'###,###'),  ' bytes of memory available');
  190.   WRITELN('>> SIZEOFMEM <<');
  191.   WRITELN('There are ',L2S(SizeOfMem,'###,###'),  ' bytes of memory installed');
  192.   WRITELN('>> STACKAVAIL <<');
  193.   WRITELN('There are ',L2S(StackAvail,'##,###'), ' bytes of stack available');
  194.   Continue;
  195. END;
  196.  
  197. PROCEDURE Gen7;
  198. BEGIN
  199.   WRITELN(' 7) Instruction Timing',^J^M);
  200.   WRITELN('>> TIMEELAPSED <<');
  201.   WRITELN('Seconds elapsed since midnight with 6 byte reals ',R2S(TimeElapsed,'###,###.@@'));
  202.   WRITELN('Seconds elapsed since midnight with 8 byte reals ',D2S(TimeElapsed,'###,###.@@'));
  203.   Start := TimeElapsed;
  204.   FOR Ctr := 1 TO MAXINT DO;
  205.   Stop := TimeElapsed;
  206.   WRITELN('>> TIMETOTAL <<');
  207.   WRITE('Seconds elapsed in null loop ',TimeTotal(Start,Stop));
  208.   Continue;
  209. END;
  210.  
  211. PROCEDURE Gen8;
  212. BEGIN
  213.   ProgName := WhoAmI;
  214.   ProgName := COPY(ProgName,1,LENGTH(Progname)-3) + 'PAS';
  215.   WRITELN(' 8) General purpose file',^J^M);
  216.   WRITELN('>> EXIST <<');
  217.   WRITELN('>> LINESINFILE <<');
  218.   WRITELN('>> GETFILEDATEANDTIMESTRING <<');
  219.   WRITELN('>> GETFILEDATEANDTIMELONGINT <<');
  220.   IF Exist(ProgName) THEN BEGIN
  221.     WRITELN('This program exists & has ',LinesInFile(ProgName),' lines of text',
  222.             ^J^M,'and has a time stamp of ',GetFileDateAndTimeString(ProgName));
  223.     WRITELN('And has a LongInt time stamp of ',GetFileDateAndTimeLongInt(ProgName));
  224.     END
  225.   ELSE WRITELN('This program doesn''t exist');
  226.   Continue;
  227. END;
  228.  
  229. PROCEDURE Gen9;
  230. BEGIN
  231.   WRITELN(' 9) Math',^J^M);
  232.   WRITELN('>> POWER <<');
  233.   WRITELN('Two to the third power is ',Power(2,3):9:4);
  234.   WRITELN('2.01 to the 3.02 power is ',Power(2.01,3.02):9:4);
  235.   WRITELN('>> LOG <<');
  236.   WRITELN('The base 10 log of 100 is ',Log(100):9:4);
  237.   Continue;
  238. END;
  239.  
  240. PROCEDURE Gen10;
  241. BEGIN
  242.   WRITELN('10) DOS and Environment',^J^M);
  243.   WRITELN('>> DOSVERSIONR <<');
  244.   WRITELN('This is DOS version ',DOSVersionR:5:2);
  245.   WRITELN('>> WHOAMI <<');
  246.   WRITELN('Currently executing program is ',WhoAmI);
  247.   WRITELN('>> GETENVSTRING <<');
  248.   WRITELN('COMSPEC is: ',GetEnvString(' COMSPEC =  '));
  249.   Continue;
  250. END;
  251.  
  252. PROCEDURE Gen11;
  253. BEGIN
  254.   WRITELN('11) Version Control',^J^M);
  255.   WRITELN('>> GETVERSION <<');
  256.   WRITELN('>> GETVERSIONS <<');
  257.   ScrStatMsg(GetDMLVersions);
  258.   Continue;
  259. END;
  260.  
  261. PROCEDURE StrgStart;
  262. BEGIN
  263.   CLRSCR;
  264.   WRITELN(CJS('STRING HANDLING ROUTINES',80));
  265. END;
  266.  
  267. PROCEDURE Strg1;
  268. BEGIN
  269.   WRITELN(' 1) General Purpose String',^J^M);
  270.   WRITELN('>> RJS <<');
  271.   WRITELN('>> LJS <<');
  272.   WRITELN('>> CJS <<');
  273.   WRITELN(LJS('Left',25),CJS('Center',25),RJS('Right',25));
  274.   Password := 'A B           c              d  E';
  275.   WRITELN('>> STRIP <<');
  276.   WRITELN(Password,' striped of all blanks and tabs ',Strip(Password,S_AllSpaces));
  277.   Password := 'A B           c              d  E';
  278.   WRITELN(Password,' upper cased ',StrCase(Password,S_ToUpper));
  279.   Password := 'Field1,Field2,Field3';
  280.   WRITELN('>> STRFIELD <<');
  281.   FOR Ctr := 1 TO 4 DO WRITELN('Field Number ',Ctr,' ',StrField(Password,',',Ctr),' ');
  282.   Password := StrFill('*',60);
  283.   WRITELN('>> STRFILL <<');
  284.   WRITELN('I see stars ',Password);
  285.   WRITELN('>> STRPAD <<');
  286.   WRITELN('Blank pad {',COPY(StrPad('ABCDEFGHIJKLMNOPQRSTUVWXYZ'),1,60),'}');
  287.   WRITELN('>> STRSHIFTLEFT <<');
  288.   WRITELN('Remove a character from string ',StrShiftLeft('ABCDEFGHIJKLMNOPQRSTUVWXYZ',13));
  289.   WRITELN('>> STRSHIFTRIGHT <<');
  290.   WRITELN('Add a character to string      ',StrShiftRight('ABCDEFGHIJKLNOPQRSTUVWXYZ',13,'m'));
  291.   Continue;
  292. END;
  293.  
  294. PROCEDURE Strg2;
  295. BEGIN
  296.   WRITELN(' 2) String Conversion',^J^M);
  297.   WRITELN('>> S2C <<');
  298.   WRITELN('>> C2S <<');
  299.   S2C('Probably use to create text import files',CharArr,255);
  300.   WRITELN(C2S(CharArr,255));
  301.   WRITELN('>> S2Z <<');
  302.   WRITELN('>> Z2S <<');
  303.   S2Z('Probably use to create c language or DOS strings',CharArr);
  304.   WRITELN(Z2S(CharArr));
  305.   Continue;
  306. END;
  307.  
  308. PROCEDURE NumStart;
  309. BEGIN
  310.   CLRSCR;
  311.   WRITELN(CJS('NUMERIC ROUTINES',80));
  312. END;
  313.  
  314. PROCEDURE Num1;
  315. BEGIN
  316.   WRITELN(' 1) General Numeric Formatting and Conversion',^J^M);
  317.   WRITELN('>> B2S <<');
  318.   WRITELN(CJS('It''s '+B2S(2+2=4)+' that 2 + 2 = 4',30),'so don''t make a ',2+2=3,' step');
  319.   WRITELN('>> W2S <<');
  320.   WRITELN('Word to String test ',W2S(MAXINT*2,'-##,##@'));
  321.   WRITELN('>> I2S <<');
  322.   WRITELN('Integer to String test ',I2S(-MAXINT,'-##,##@'));
  323.   WRITELN('>> L2S <<');
  324.   WRITELN('Long Integer to String tests ',L2S(MAXINT*100,'###,###,##@'),'    '
  325.                                          ,L2S(-1116665555,'(###) ###-####'));
  326.   WRITELN('>> R2S <<');
  327.   WRITELN('Seconds elapsed since midnight with 6 byte reals ',R2S(TimeElapsed,'###,###.@@'),'  '
  328.                                          ,R2S(-9996665555.0,'(###) ###-####'));
  329.   WRITELN('>> D2S <<');
  330.   WRITELN('Seconds elapsed since midnight with 8 byte reals ',D2S(TimeElapsed,'###,###.@@'));
  331.   WRITELN('>> S2R <<');
  332.   WRITELN('String to real   test ',S2R('123456789.987654321'):20:10);
  333.   WRITELN('>> S2D <<');
  334.   WRITELN('String to double test ',S2D('123456789.987654321'):20:10);
  335.   Continue;
  336.   WRITELN('>> StrNumTest <<');
  337.   WRITELN('Test string for numerics: enter test strings, terminate with * ');
  338.   REPEAT
  339.     READLN(Password);
  340.     StrNum := StrNumTest(Password);
  341.     CASE StrNum OF
  342.       StrNonNumeric : WRITELN('String has no numeric characters');
  343.       StrZero       : WRITELN('String has numeric value of zero');
  344.       StrNonZero    : WRITELN('String has numeric value of non zero');
  345.       END;
  346.     UNTIL Password = '*';
  347.   WRITELN('>> S2L <<');
  348.   WRITELN('String to Long Integer test ',S2L('123456789'));
  349.   WRITELN('>> S2I <<');
  350.   WRITELN('String to Integer test ',S2I('-12345'));
  351.   WRITELN('>> S2W <<');
  352.   WRITELN('String to Word ',S2W('65001'));
  353.   Continue;
  354. END;
  355.  
  356. PROCEDURE Num2;
  357. BEGIN
  358.   WRITELN(' 2) Date and Time Formatting and Conversion',^J^M);
  359.   WRITELN('>> NUMTH <<');
  360.   WRITELN('Sunday is the ',NumTh(1),' day of the week');
  361.   WRITELN('>> GETDOSDATEANDTIME <<');
  362.   WRITELN('>> DATE2S <<');
  363.   GetDOSDateAndTime(JulSec,DateTime);
  364.   WRITELN('Today is: ',Date2S(DateTime,' WWW MM/DD/YY hh:mm:ss pm'));
  365.   WRITELN('Julian seconds since 12/31/1840 ',JulSec:15:1);
  366.   JulSec := JulSec + 60*60*24;
  367.   WRITELN('>> R2DATE <<');
  368.   R2Date(JulSec,DateTime);
  369.   WRITELN('Tomorrow is: ',Date2S(DateTime,' WWW MM/DD/YY hh:mm:ss pm'));
  370.   INC(DateTime.Year);
  371.   WRITELN('>> DATE2R <<');
  372.   Date2R(JulSec,DateTime);
  373.   R2Date(JulSec,DateTime);
  374.   WRITELN('Next Year is: ',Date2S(DateTime,' WWW MM/DD/YY hh:mm:ss pm'));
  375.   WRITELN('>> SETDOSDATEANDTIME <<');
  376.   SetDOSDateAndTime(DateTime);
  377.   DEC(DateTime.Year);
  378.   DEC(DateTime.Day);
  379.   SetDOSDateAndTime(DateTime);
  380.   Continue;
  381. END;
  382.  
  383. PROCEDURE KbdStart;
  384. BEGIN
  385.   CLRSCR;
  386.   WRITELN(CJS('KEYBOARD ROUTINES',80));
  387. END;
  388.  
  389. PROCEDURE Kbd1;
  390. BEGIN
  391.   WRITELN(' 1) General Purpose Keyboard',^J^M);
  392.   WRITELN('>> KBDGETSTATUS <<');
  393.   WRITELN(W2S(KbdGetStatus,'HHHH'));
  394.   WRITELN('>> KBDSETINSMODE <<');
  395.   KbdSetInsMode(ON);
  396.   WRITELN('>> KBDSETCAPSLOCK <<');
  397.   KbdSetCapsLock(ON);
  398.   WRITELN('>> KBDSETNUMLOCK <<');
  399.   KbdSetNumLock(ON);
  400.   WRITELN('>> KBDSETSCROLLLOCK <<');
  401.   KbdSetScrollLock(ON);
  402.   WRITELN(W2S(KbdGetStatus,'HHHH'));
  403.   WRITELN('>> KBDINSMODESTATUS <<');
  404.   WRITELN(KbdInsModeStatus);
  405.   WRITELN('>> KBDCAPSLOCKSTATUS <<');
  406.   WRITELN(KbdCapsLockStatus);
  407.   WRITELN('>> KBDNUMLOCKSTATUS <<');
  408.   WRITELN(KbdNumLockStatus);
  409.   WRITELN('>> KBDSCROLLLOCKSTATUS <<');
  410.   WRITELN(KbdScrollLockStatus);
  411.   WRITELN('>> KBDCLEAR <<');
  412.   KbdClear;
  413.   WRITELN('>> KBDIKEYWAITING <<');
  414.   WRITELN('Please press any key');
  415.   REPEAT
  416.     UNTIL KbdKeyWaiting;
  417.   WRITELN('>> KBDNUMVALUESWAITING <<');
  418.   WRITELN('Number of keystrokes entered ',KbdNumValuesWaiting);
  419.   WRITELN('>> KBDINPUTVALUE <<');
  420.   WRITELN(KbdInputValue);
  421.   KbdClear;
  422.   Continue;
  423. END;
  424.  
  425. PROCEDURE Die;
  426. BEGIN
  427.   WRITELN('About to do a user defined abend on purpose');
  428.   DELAY(2000);
  429.   WRITELN('>> ABEND <<');
  430.   Abend(250,NIL);
  431. END;
  432.  
  433. BEGIN
  434.   GenStart;         { GENERAL PURPOSE ROUTINES }
  435.   Gen1;             { System Programming Extensions }
  436.   Gen2;             { File I/O and protection }
  437.   Gen3;             { Text Encryption }
  438.   Gen4;             { General Purpose Video }
  439.   Gen5;             { Video Messages }
  440.   Gen6;             { Disk and Memory Sizes }
  441.   Gen7;             { Instruction Timing }
  442.   Gen8;             { General Purpose File }
  443.   Gen9;             { Math }
  444.   Gen10;            { DOS and Environment }
  445.   Gen11;            { Version Control }
  446.   StrgStart;        { STRING HANDLING ROUTINES }
  447.   Strg1;            { General Purpose String }
  448.   Strg2;            { String Conversion }
  449.   NumStart;         { NUMERIC ROUTINES }
  450.   Num1;             { General Formatting and Conversion }
  451.   Num2;             { Date and Time Formatting and Conversion }
  452.   KbdStart;         { KEYBOARD ROUTINES }
  453.   Kbd1;             { General Purpose Keyboard }
  454.   Die;              { System Programming Extensions }
  455. END.